home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / tcltk / tk8.4 / menu.tcl < prev    next >
Text File  |  2009-04-29  |  36KB  |  1,304 lines
  1. # menu.tcl --
  2. #
  3. # This file defines the default bindings for Tk menus and menubuttons.
  4. # It also implements keyboard traversal of menus and implements a few
  5. # other utility procedures related to menus.
  6. #
  7. # RCS: @(#) $Id: menu.tcl,v 1.18.2.5 2007/11/09 06:26:54 das Exp $
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11. # Copyright (c) 1998-1999 by Scriptics Corporation.
  12. # Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
  13. #
  14. # See the file "license.terms" for information on usage and redistribution
  15. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16. #
  17.  
  18. #-------------------------------------------------------------------------
  19. # Elements of tk::Priv that are used in this file:
  20. #
  21. # cursor -        Saves the -cursor option for the posted menubutton.
  22. # focus -        Saves the focus during a menu selection operation.
  23. #            Focus gets restored here when the menu is unposted.
  24. # grabGlobal -        Used in conjunction with tk::Priv(oldGrab):  if
  25. #            tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal)
  26. #            contains either an empty string or "-global" to
  27. #            indicate whether the old grab was a local one or
  28. #            a global one.
  29. # inMenubutton -    The name of the menubutton widget containing
  30. #            the mouse, or an empty string if the mouse is
  31. #            not over any menubutton.
  32. # menuBar -        The name of the menubar that is the root
  33. #            of the cascade hierarchy which is currently
  34. #            posted. This is null when there is no menu currently
  35. #            being pulled down from a menu bar.
  36. # oldGrab -        Window that had the grab before a menu was posted.
  37. #            Used to restore the grab state after the menu
  38. #            is unposted.  Empty string means there was no
  39. #            grab previously set.
  40. # popup -        If a menu has been popped up via tk_popup, this
  41. #            gives the name of the menu.  Otherwise this
  42. #            value is empty.
  43. # postedMb -        Name of the menubutton whose menu is currently
  44. #            posted, or an empty string if nothing is posted
  45. #            A grab is set on this widget.
  46. # relief -        Used to save the original relief of the current
  47. #            menubutton.
  48. # window -        When the mouse is over a menu, this holds the
  49. #            name of the menu;  it's cleared when the mouse
  50. #            leaves the menu.
  51. # tearoff -        Whether the last menu posted was a tearoff or not.
  52. #            This is true always for unix, for tearoffs for Mac
  53. #            and Windows.
  54. # activeMenu -        This is the last active menu for use
  55. #            with the <<MenuSelect>> virtual event.
  56. # activeItem -        This is the last active menu item for
  57. #            use with the <<MenuSelect>> virtual event.
  58. #-------------------------------------------------------------------------
  59.  
  60. #-------------------------------------------------------------------------
  61. # Overall note:
  62. # This file is tricky because there are five different ways that menus
  63. # can be used:
  64. #
  65. # 1. As a pulldown from a menubutton. In this style, the variable 
  66. #    tk::Priv(postedMb) identifies the posted menubutton.
  67. # 2. As a torn-off menu copied from some other menu.  In this style
  68. #    tk::Priv(postedMb) is empty, and menu's type is "tearoff".
  69. # 3. As an option menu, triggered from an option menubutton.  In this
  70. #    style tk::Priv(postedMb) identifies the posted menubutton.
  71. # 4. As a popup menu.  In this style tk::Priv(postedMb) is empty and
  72. #    the top-level menu's type is "normal".
  73. # 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has
  74. #    the owning menubar, and the menu itself is of type "normal".
  75. #
  76. # The various binding procedures use the  state described above to
  77. # distinguish the various cases and take different actions in each
  78. # case.
  79. #-------------------------------------------------------------------------
  80.  
  81. #-------------------------------------------------------------------------
  82. # The code below creates the default class bindings for menus
  83. # and menubuttons.
  84. #-------------------------------------------------------------------------
  85.  
  86. bind Menubutton <FocusIn> {}
  87. bind Menubutton <Enter> {
  88.     tk::MbEnter %W
  89. }
  90. bind Menubutton <Leave> {
  91.     tk::MbLeave %W
  92. }
  93. bind Menubutton <1> {
  94.     if {$tk::Priv(inMenubutton) ne ""} {
  95.     tk::MbPost $tk::Priv(inMenubutton) %X %Y
  96.     }
  97. }
  98. bind Menubutton <Motion> {
  99.     tk::MbMotion %W up %X %Y
  100. }
  101. bind Menubutton <B1-Motion> {
  102.     tk::MbMotion %W down %X %Y
  103. }
  104. bind Menubutton <ButtonRelease-1> {
  105.     tk::MbButtonUp %W
  106. }
  107. bind Menubutton <space> {
  108.     tk::MbPost %W
  109.     tk::MenuFirstEntry [%W cget -menu]
  110. }
  111.  
  112. # Must set focus when mouse enters a menu, in order to allow
  113. # mixed-mode processing using both the mouse and the keyboard.
  114. # Don't set the focus if the event comes from a grab release,
  115. # though:  such an event can happen after as part of unposting
  116. # a cascaded chain of menus, after the focus has already been
  117. # restored to wherever it was before menu selection started.
  118.  
  119. bind Menu <FocusIn> {}
  120.  
  121. bind Menu <Enter> {
  122.     set tk::Priv(window) %W
  123.     if {[%W cget -type] eq "tearoff"} {
  124.     if {"%m" ne "NotifyUngrab"} {
  125.         if {[tk windowingsystem] eq "x11"} {
  126.         tk_menuSetFocus %W
  127.         }
  128.     }
  129.     }
  130.     tk::MenuMotion %W %x %y %s
  131. }
  132.  
  133. bind Menu <Leave> {
  134.     tk::MenuLeave %W %X %Y %s
  135. }
  136. bind Menu <Motion> {
  137.     tk::MenuMotion %W %x %y %s
  138. }
  139. bind Menu <ButtonPress> {
  140.     tk::MenuButtonDown %W
  141. }
  142. bind Menu <ButtonRelease> {
  143.    tk::MenuInvoke %W 1
  144. }
  145. bind Menu <space> {
  146.     tk::MenuInvoke %W 0
  147. }
  148. bind Menu <Return> {
  149.     tk::MenuInvoke %W 0
  150. }
  151. bind Menu <Escape> {
  152.     tk::MenuEscape %W
  153. }
  154. bind Menu <Left> {
  155.     tk::MenuLeftArrow %W
  156. }
  157. bind Menu <Right> {
  158.     tk::MenuRightArrow %W
  159. }
  160. bind Menu <Up> {
  161.     tk::MenuUpArrow %W
  162. }
  163. bind Menu <Down> {
  164.     tk::MenuDownArrow %W
  165. }
  166. bind Menu <KeyPress> {
  167.     tk::TraverseWithinMenu %W %A
  168. }
  169.  
  170. # The following bindings apply to all windows, and are used to
  171. # implement keyboard menu traversal.
  172.  
  173. if {[tk windowingsystem] eq "x11"} {
  174.     bind all <Alt-KeyPress> {
  175.     tk::TraverseToMenu %W %A
  176.     }
  177.  
  178.     bind all <F10> {
  179.     tk::FirstMenu %W
  180.     }
  181. } else {
  182.     bind Menubutton <Alt-KeyPress> {
  183.     tk::TraverseToMenu %W %A
  184.     }
  185.  
  186.     bind Menubutton <F10> {
  187.     tk::FirstMenu %W
  188.     }
  189. }
  190.  
  191. # ::tk::MbEnter --
  192. # This procedure is invoked when the mouse enters a menubutton
  193. # widget.  It activates the widget unless it is disabled.  Note:
  194. # this procedure is only invoked when mouse button 1 is *not* down.
  195. # The procedure ::tk::MbB1Enter is invoked if the button is down.
  196. #
  197. # Arguments:
  198. # w -            The  name of the widget.
  199.  
  200. proc ::tk::MbEnter w {
  201.     variable ::tk::Priv
  202.  
  203.     if {$Priv(inMenubutton) ne ""} {
  204.     MbLeave $Priv(inMenubutton)
  205.     }
  206.     set Priv(inMenubutton) $w
  207.     if {[$w cget -state] ne "disabled" && [tk windowingsystem] ne "aqua"} {
  208.     $w configure -state active
  209.     }
  210. }
  211.  
  212. # ::tk::MbLeave --
  213. # This procedure is invoked when the mouse leaves a menubutton widget.
  214. # It de-activates the widget, if the widget still exists.
  215. #
  216. # Arguments:
  217. # w -            The  name of the widget.
  218.  
  219. proc ::tk::MbLeave w {
  220.     variable ::tk::Priv
  221.  
  222.     set Priv(inMenubutton) {}
  223.     if {![winfo exists $w]} {
  224.     return
  225.     }
  226.     if {[$w cget -state] eq "active" && [tk windowingsystem] ne "aqua"} {
  227.     $w configure -state normal
  228.     }
  229. }
  230.  
  231. # ::tk::MbPost --
  232. # Given a menubutton, this procedure does all the work of posting
  233. # its associated menu and unposting any other menu that is currently
  234. # posted.
  235. #
  236. # Arguments:
  237. # w -            The name of the menubutton widget whose menu
  238. #            is to be posted.
  239. # x, y -        Root coordinates of cursor, used for positioning
  240. #            option menus.  If not specified, then the center
  241. #            of the menubutton is used for an option menu.
  242.  
  243. proc ::tk::MbPost {w {x {}} {y {}}} {
  244.     global errorInfo
  245.     variable ::tk::Priv
  246.     global tcl_platform
  247.  
  248.     if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} {
  249.     return
  250.     }
  251.     set menu [$w cget -menu]
  252.     if {$menu eq ""} {
  253.     return
  254.     }
  255.     set tearoff [expr {[tk windowingsystem] eq "x11" \
  256.         || [$menu cget -type] eq "tearoff"}]
  257.     if {[string first $w $menu] != 0} {
  258.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  259.     }
  260.     set cur $Priv(postedMb)
  261.     if {$cur ne ""} {
  262.     MenuUnpost {}
  263.     }
  264.     set Priv(cursor) [$w cget -cursor]
  265.     $w configure -cursor arrow
  266.     if {[tk windowingsystem] ne "aqua"} {
  267.     set Priv(relief) [$w cget -relief]
  268.     $w configure -relief raised
  269.     } else {
  270.     $w configure -state active
  271.     }
  272.  
  273.     set Priv(postedMb) $w
  274.     set Priv(focus) [focus]
  275.     $menu activate none
  276.     GenerateMenuSelect $menu
  277.  
  278.     # If this looks like an option menubutton then post the menu so
  279.     # that the current entry is on top of the mouse.  Otherwise post
  280.     # the menu just below the menubutton, as for a pull-down.
  281.  
  282.     update idletasks
  283.     if {[catch {
  284.     switch [$w cget -direction] {
  285.             above {
  286.                 set x [winfo rootx $w]
  287.                 set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
  288.         # if we go offscreen to the top, show as 'below'
  289.         if {$y < 0} {
  290.             set y [expr {[winfo rooty $w] + [winfo height $w]}]
  291.         }
  292.         PostOverPoint $menu $x $y
  293.             }
  294.             below {
  295.                 set x [winfo rootx $w]
  296.                 set y [expr {[winfo rooty $w] + [winfo height $w]}]
  297.         # if we go offscreen to the bottom, show as 'above'
  298.         set mh [winfo reqheight $menu]
  299.         if {($y + $mh) > [winfo screenheight $w]} {
  300.             set y [expr {[winfo rooty $w] - $mh}]
  301.         }
  302.         PostOverPoint $menu $x $y
  303.             }
  304.             left {
  305.                 set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
  306.                 set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
  307.                 set entry [MenuFindName $menu [$w cget -text]]
  308.                 if {[$w cget -indicatoron]} {
  309.             if {$entry == [$menu index last]} {
  310.                 incr y [expr {-([$menu yposition $entry] \
  311.                     + [winfo reqheight $menu])/2}]
  312.             } else {
  313.                 incr y [expr {-([$menu yposition $entry] \
  314.                     + [$menu yposition [expr {$entry+1}]])/2}]
  315.             }
  316.                 }
  317.         PostOverPoint $menu $x $y
  318.         if {$entry ne "" \
  319.             && [$menu entrycget $entry -state] ne "disabled"} {
  320.                     $menu activate $entry
  321.             GenerateMenuSelect $menu
  322.                 }
  323.             }
  324.             right {
  325.                 set x [expr {[winfo rootx $w] + [winfo width $w]}]
  326.                 set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
  327.                 set entry [MenuFindName $menu [$w cget -text]]
  328.                 if {[$w cget -indicatoron]} {
  329.             if {$entry == [$menu index last]} {
  330.                 incr y [expr {-([$menu yposition $entry] \
  331.                     + [winfo reqheight $menu])/2}]
  332.             } else {
  333.                 incr y [expr {-([$menu yposition $entry] \
  334.                     + [$menu yposition [expr {$entry+1}]])/2}]
  335.             }
  336.                 }
  337.         PostOverPoint $menu $x $y
  338.         if {$entry ne "" \
  339.             && [$menu entrycget $entry -state] ne "disabled"} {
  340.                     $menu activate $entry
  341.             GenerateMenuSelect $menu
  342.                 }
  343.             }
  344.             default {
  345.                 if {[$w cget -indicatoron]} {
  346.             if {$y eq ""} {
  347.             set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
  348.             set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
  349.                 }
  350.                 PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]]
  351.         } else {
  352.             PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
  353.                 }
  354.             }
  355.     }
  356.     } msg]} {
  357.     # Error posting menu (e.g. bogus -postcommand). Unpost it and
  358.     # reflect the error.
  359.     
  360.     set savedInfo $errorInfo
  361.     MenuUnpost {}
  362.     error $msg $savedInfo
  363.  
  364.     }
  365.  
  366.     set Priv(tearoff) $tearoff
  367.     if {$tearoff != 0} {
  368.         focus $menu
  369.     if {[winfo viewable $w]} {
  370.         SaveGrabInfo $w
  371.         grab -global $w
  372.     }
  373.     }
  374. }
  375.  
  376. # ::tk::MenuUnpost --
  377. # This procedure unposts a given menu, plus all of its ancestors up
  378. # to (and including) a menubutton, if any.  It also restores various
  379. # values to what they were before the menu was posted, and releases
  380. # a grab if there's a menubutton involved.  Special notes:
  381. # 1. It's important to unpost all menus before releasing the grab, so
  382. #    that any Enter-Leave events (e.g. from menu back to main
  383. #    application) have mode NotifyGrab.
  384. # 2. Be sure to enclose various groups of commands in "catch" so that
  385. #    the procedure will complete even if the menubutton or the menu
  386. #    or the grab window has been deleted.
  387. #
  388. # Arguments:
  389. # menu -        Name of a menu to unpost.  Ignored if there
  390. #            is a posted menubutton.
  391.  
  392. proc ::tk::MenuUnpost menu {
  393.     global tcl_platform
  394.     variable ::tk::Priv
  395.     set mb $Priv(postedMb)
  396.  
  397.     # Restore focus right away (otherwise X will take focus away when
  398.     # the menu is unmapped and under some window managers (e.g. olvwm)
  399.     # we'll lose the focus completely).
  400.  
  401.     catch {focus $Priv(focus)}
  402.     set Priv(focus) ""
  403.  
  404.     # Unpost menu(s) and restore some stuff that's dependent on
  405.     # what was posted.
  406.  
  407.     catch {
  408.     if {$mb ne ""} {
  409.         set menu [$mb cget -menu]
  410.         $menu unpost
  411.         set Priv(postedMb) {}
  412.         $mb configure -cursor $Priv(cursor)
  413.         if {[tk windowingsystem] ne "aqua"} {
  414.         $mb configure -relief $Priv(relief)
  415.         } else {
  416.         $mb configure -state normal
  417.         }
  418.     } elseif {$Priv(popup) ne ""} {
  419.         $Priv(popup) unpost
  420.         set Priv(popup) {}
  421.     } elseif {[$menu cget -type] ne "menubar" && [$menu cget -type] ne "tearoff"} {
  422.         # We're in a cascaded sub-menu from a torn-off menu or popup.
  423.         # Unpost all the menus up to the toplevel one (but not
  424.         # including the top-level torn-off one) and deactivate the
  425.         # top-level torn off menu if there is one.
  426.  
  427.         while {1} {
  428.         set parent [winfo parent $menu]
  429.         if {[winfo class $parent] ne "Menu" || ![winfo ismapped $parent]} {
  430.             break
  431.         }
  432.         $parent activate none
  433.         $parent postcascade none
  434.         GenerateMenuSelect $parent
  435.         set type [$parent cget -type]
  436.         if {$type eq "menubar" || $type eq "tearoff"} {
  437.             break
  438.         }
  439.         set menu $parent
  440.         }
  441.         if {[$menu cget -type] ne "menubar"} {
  442.         $menu unpost
  443.         }
  444.     }
  445.     }
  446.  
  447.     if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} {
  448.         # Release grab, if any, and restore the previous grab, if there
  449.         # was one.
  450.     if {$menu ne ""} {
  451.         set grab [grab current $menu]
  452.         if {$grab ne ""} {
  453.         grab release $grab
  454.         }
  455.     }
  456.     RestoreOldGrab
  457.     if {$Priv(menuBar) ne ""} {
  458.         $Priv(menuBar) configure -cursor $Priv(cursor)
  459.         set Priv(menuBar) {}
  460.     }
  461.     if {[tk windowingsystem] ne "x11"} {
  462.         set Priv(tearoff) 0
  463.     }
  464.     }
  465. }
  466.  
  467. # ::tk::MbMotion --
  468. # This procedure handles mouse motion events inside menubuttons, and
  469. # also outside menubuttons when a menubutton has a grab (e.g. when a
  470. # menu selection operation is in progress).
  471. #
  472. # Arguments:
  473. # w -            The name of the menubutton widget.
  474. # upDown -         "down" means button 1 is pressed, "up" means
  475. #            it isn't.
  476. # rootx, rooty -    Coordinates of mouse, in (virtual?) root window.
  477.  
  478. proc ::tk::MbMotion {w upDown rootx rooty} {
  479.     variable ::tk::Priv
  480.  
  481.     if {$Priv(inMenubutton) eq $w} {
  482.     return
  483.     }
  484.     set new [winfo containing $rootx $rooty]
  485.     if {$new ne $Priv(inMenubutton) \
  486.         && ($new eq "" || [winfo toplevel $new] eq [winfo toplevel $w])} {
  487.     if {$Priv(inMenubutton) ne ""} {
  488.         MbLeave $Priv(inMenubutton)
  489.     }
  490.     if {$new ne "" \
  491.         && [winfo class $new] eq "Menubutton" \
  492.         && ([$new cget -indicatoron] == 0) \
  493.         && ([$w cget -indicatoron] == 0)} {
  494.         if {$upDown eq "down"} {
  495.         MbPost $new $rootx $rooty
  496.         } else {
  497.         MbEnter $new
  498.         }
  499.     }
  500.     }
  501. }
  502.  
  503. # ::tk::MbButtonUp --
  504. # This procedure is invoked to handle button 1 releases for menubuttons.
  505. # If the release happens inside the menubutton then leave its menu
  506. # posted with element 0 activated.  Otherwise, unpost the menu.
  507. #
  508. # Arguments:
  509. # w -            The name of the menubutton widget.
  510.  
  511. proc ::tk::MbButtonUp w {
  512.     variable ::tk::Priv
  513.     global tcl_platform
  514.  
  515.     set menu [$w cget -menu]
  516.     set tearoff [expr {[tk windowingsystem] eq "x11" || \
  517.         ($menu ne "" && [$menu cget -type] eq "tearoff")}]
  518.     if {($tearoff != 0) && $Priv(postedMb) eq $w \
  519.         && $Priv(inMenubutton) eq $w} {
  520.     MenuFirstEntry [$Priv(postedMb) cget -menu]
  521.     } else {
  522.     MenuUnpost {}
  523.     }
  524. }
  525.  
  526. # ::tk::MenuMotion --
  527. # This procedure is called to handle mouse motion events for menus.
  528. # It does two things.  First, it resets the active element in the
  529. # menu, if the mouse is over the menu.  Second, if a mouse button
  530. # is down, it posts and unposts cascade entries to match the mouse
  531. # position.
  532. #
  533. # Arguments:
  534. # menu -        The menu window.
  535. # x -            The x position of the mouse.
  536. # y -            The y position of the mouse.
  537. # state -        Modifier state (tells whether buttons are down).
  538.  
  539. proc ::tk::MenuMotion {menu x y state} {
  540.     variable ::tk::Priv
  541.     if {$menu eq $Priv(window)} {
  542.     if {[$menu cget -type] eq "menubar"} {
  543.         if {[info exists Priv(focus)] && $menu ne $Priv(focus)} {
  544.         $menu activate @$x,$y
  545.         GenerateMenuSelect $menu
  546.         }
  547.     } else {
  548.         $menu activate @$x,$y
  549.         GenerateMenuSelect $menu
  550.     }
  551.     }
  552.     if {($state & 0x1f00) != 0} {
  553.     $menu postcascade active
  554.     }
  555. }
  556.  
  557. # ::tk::MenuButtonDown --
  558. # Handles button presses in menus.  There are a couple of tricky things
  559. # here:
  560. # 1. Change the posted cascade entry (if any) to match the mouse position.
  561. # 2. If there is a posted menubutton, must grab to the menubutton;  this
  562. #    overrrides the implicit grab on button press, so that the menu
  563. #    button can track mouse motions over other menubuttons and change
  564. #    the posted menu.
  565. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  566. #    or one of its descendants) must grab to the top-level menu so that
  567. #    we can track mouse motions across the entire menu hierarchy.
  568. #
  569. # Arguments:
  570. # menu -        The menu window.
  571.  
  572. proc ::tk::MenuButtonDown menu {
  573.     variable ::tk::Priv
  574.     global tcl_platform
  575.  
  576.     if {![winfo viewable $menu]} {
  577.         return
  578.     }
  579.     $menu postcascade active
  580.     if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} {
  581.     grab -global $Priv(postedMb)
  582.     } else {
  583.     while {[$menu cget -type] eq "normal" \
  584.         && [winfo class [winfo parent $menu]] eq "Menu" \
  585.         && [winfo ismapped [winfo parent $menu]]} {
  586.         set menu [winfo parent $menu]
  587.     }
  588.  
  589.     if {$Priv(menuBar) eq ""} {
  590.         set Priv(menuBar) $menu
  591.         set Priv(cursor) [$menu cget -cursor]
  592.         $menu configure -cursor arrow
  593.         }
  594.  
  595.     # Don't update grab information if the grab window isn't changing.
  596.     # Otherwise, we'll get an error when we unpost the menus and
  597.     # restore the grab, since the old grab window will not be viewable
  598.     # anymore.
  599.  
  600.     if {$menu ne [grab current $menu]} {
  601.         SaveGrabInfo $menu
  602.     }
  603.  
  604.     # Must re-grab even if the grab window hasn't changed, in order
  605.     # to release the implicit grab from the button press.
  606.  
  607.     if {[tk windowingsystem] eq "x11"} {
  608.         grab -global $menu
  609.     }
  610.     }
  611. }
  612.  
  613. # ::tk::MenuLeave --
  614. # This procedure is invoked to handle Leave events for a menu.  It
  615. # deactivates everything unless the active element is a cascade element
  616. # and the mouse is now over the submenu.
  617. #
  618. # Arguments:
  619. # menu -        The menu window.
  620. # rootx, rooty -    Root coordinates of mouse.
  621. # state -        Modifier state.
  622.  
  623. proc ::tk::MenuLeave {menu rootx rooty state} {
  624.     variable ::tk::Priv
  625.     set Priv(window) {}
  626.     if {[$menu index active] eq "none"} {
  627.     return
  628.     }
  629.     if {[$menu type active] eq "cascade" \
  630.         && [winfo containing $rootx $rooty] eq [$menu entrycget active -menu]} {
  631.     return
  632.     }
  633.     $menu activate none
  634.     GenerateMenuSelect $menu
  635. }
  636.  
  637. # ::tk::MenuInvoke --
  638. # This procedure is invoked when button 1 is released over a menu.
  639. # It invokes the appropriate menu action and unposts the menu if
  640. # it came from a menubutton.
  641. #
  642. # Arguments:
  643. # w -            Name of the menu widget.
  644. # buttonRelease -    1 means this procedure is called because of
  645. #            a button release;  0 means because of keystroke.
  646.  
  647. proc ::tk::MenuInvoke {w buttonRelease} {
  648.     variable ::tk::Priv
  649.  
  650.     if {$buttonRelease && $Priv(window) eq ""} {
  651.     # Mouse was pressed over a menu without a menu button, then
  652.     # dragged off the menu (possibly with a cascade posted) and
  653.     # released.  Unpost everything and quit.
  654.  
  655.     $w postcascade none
  656.     $w activate none
  657.     event generate $w <<MenuSelect>>
  658.     MenuUnpost $w
  659.     return
  660.     }
  661.     if {[$w type active] eq "cascade"} {
  662.     $w postcascade active
  663.     set menu [$w entrycget active -menu]
  664.     MenuFirstEntry $menu
  665.     } elseif {[$w type active] eq "tearoff"} {
  666.     ::tk::TearOffMenu $w
  667.     MenuUnpost $w
  668.     } elseif {[$w cget -type] eq "menubar"} {
  669.     $w postcascade none
  670.     set active [$w index active]
  671.     set isCascade [string equal [$w type $active] "cascade"]
  672.  
  673.     # Only de-activate the active item if it's a cascade; this prevents
  674.     # the annoying "activation flicker" you otherwise get with 
  675.     # checkbuttons/commands/etc. on menubars
  676.  
  677.     if { $isCascade } {
  678.         $w activate none
  679.         event generate $w <<MenuSelect>>
  680.     }
  681.  
  682.     MenuUnpost $w
  683.  
  684.     # If the active item is not a cascade, invoke it.  This enables
  685.     # the use of checkbuttons/commands/etc. on menubars (which is legal,
  686.     # but not recommended)
  687.  
  688.     if { !$isCascade } {
  689.         uplevel #0 [list $w invoke $active]
  690.     }
  691.     } else {
  692.     set active [$w index active]
  693.     if {$Priv(popup) eq "" || $active ne "none"} {
  694.         MenuUnpost $w
  695.     }
  696.     uplevel #0 [list $w invoke active]
  697.     }
  698. }
  699.  
  700. # ::tk::MenuEscape --
  701. # This procedure is invoked for the Cancel (or Escape) key.  It unposts
  702. # the given menu and, if it is the top-level menu for a menu button,
  703. # unposts the menu button as well.
  704. #
  705. # Arguments:
  706. # menu -        Name of the menu window.
  707.  
  708. proc ::tk::MenuEscape menu {
  709.     set parent [winfo parent $menu]
  710.     if {[winfo class $parent] ne "Menu"} {
  711.     MenuUnpost $menu
  712.     } elseif {[$parent cget -type] eq "menubar"} {
  713.     MenuUnpost $menu
  714.     RestoreOldGrab
  715.     } else {
  716.     MenuNextMenu $menu left
  717.     }
  718. }
  719.  
  720. # The following routines handle arrow keys. Arrow keys behave
  721. # differently depending on whether the menu is a menu bar or not.
  722.  
  723. proc ::tk::MenuUpArrow {menu} {
  724.     if {[$menu cget -type] eq "menubar"} {
  725.     MenuNextMenu $menu left
  726.     } else {
  727.     MenuNextEntry $menu -1
  728.     }
  729. }
  730.  
  731. proc ::tk::MenuDownArrow {menu} {
  732.     if {[$menu cget -type] eq "menubar"} {
  733.     MenuNextMenu $menu right
  734.     } else {
  735.     MenuNextEntry $menu 1
  736.     }
  737. }
  738.  
  739. proc ::tk::MenuLeftArrow {menu} {
  740.     if {[$menu cget -type] eq "menubar"} {
  741.     MenuNextEntry $menu -1
  742.     } else {
  743.     MenuNextMenu $menu left
  744.     }
  745. }
  746.  
  747. proc ::tk::MenuRightArrow {menu} {
  748.     if {[$menu cget -type] eq "menubar"} {
  749.     MenuNextEntry $menu 1
  750.     } else {
  751.     MenuNextMenu $menu right
  752.     }
  753. }
  754.  
  755. # ::tk::MenuNextMenu --
  756. # This procedure is invoked to handle "left" and "right" traversal
  757. # motions in menus.  It traverses to the next menu in a menu bar,
  758. # or into or out of a cascaded menu.
  759. #
  760. # Arguments:
  761. # menu -        The menu that received the keyboard
  762. #            event.
  763. # direction -        Direction in which to move: "left" or "right"
  764.  
  765. proc ::tk::MenuNextMenu {menu direction} {
  766.     variable ::tk::Priv
  767.  
  768.     # First handle traversals into and out of cascaded menus.
  769.  
  770.     if {$direction eq "right"} {
  771.     set count 1
  772.     set parent [winfo parent $menu]
  773.     set class [winfo class $parent]
  774.     if {[$menu type active] eq "cascade"} {
  775.         $menu postcascade active
  776.         set m2 [$menu entrycget active -menu]
  777.         if {$m2 ne ""} {
  778.         MenuFirstEntry $m2
  779.         }
  780.         return
  781.     } else {
  782.         set parent [winfo parent $menu]
  783.         while {$parent ne "."} {
  784.         if {[winfo class $parent] eq "Menu" && [$parent cget -type] eq "menubar"} {
  785.             tk_menuSetFocus $parent
  786.             MenuNextEntry $parent 1
  787.             return
  788.         }
  789.         set parent [winfo parent $parent]
  790.         }
  791.     }
  792.     } else {
  793.     set count -1
  794.     set m2 [winfo parent $menu]
  795.     if {[winfo class $m2] eq "Menu"} {
  796.         $menu activate none
  797.         GenerateMenuSelect $menu
  798.         tk_menuSetFocus $m2
  799.  
  800.         $m2 postcascade none
  801.  
  802.         if {[$m2 cget -type] ne "menubar"} {
  803.         return
  804.         }
  805.     }
  806.     }
  807.  
  808.     # Can't traverse into or out of a cascaded menu.  Go to the next
  809.     # or previous menubutton, if that makes sense.
  810.  
  811.     set m2 [winfo parent $menu]
  812.     if {[winfo class $m2] eq "Menu"} {
  813.     if {[$m2 cget -type] eq "menubar"} {
  814.         tk_menuSetFocus $m2
  815.         MenuNextEntry $m2 -1
  816.         return
  817.     }
  818.     }
  819.  
  820.     set w $Priv(postedMb)
  821.     if {$w eq ""} {
  822.     return
  823.     }
  824.     set buttons [winfo children [winfo parent $w]]
  825.     set length [llength $buttons]
  826.     set i [expr {[lsearch -exact $buttons $w] + $count}]
  827.     while {1} {
  828.     while {$i < 0} {
  829.         incr i $length
  830.     }
  831.     while {$i >= $length} {
  832.         incr i -$length
  833.     }
  834.     set mb [lindex $buttons $i]
  835.     if {[winfo class $mb] eq "Menubutton" \
  836.         && [$mb cget -state] ne "disabled" \
  837.         && [$mb cget -menu] ne "" \
  838.         && [[$mb cget -menu] index last] ne "none"} {
  839.         break
  840.     }
  841.     if {$mb eq $w} {
  842.         return
  843.     }
  844.     incr i $count
  845.     }
  846.     MbPost $mb
  847.     MenuFirstEntry [$mb cget -menu]
  848. }
  849.  
  850. # ::tk::MenuNextEntry --
  851. # Activate the next higher or lower entry in the posted menu,
  852. # wrapping around at the ends.  Disabled entries are skipped.
  853. #
  854. # Arguments:
  855. # menu -            Menu window that received the keystroke.
  856. # count -            1 means go to the next lower entry,
  857. #                -1 means go to the next higher entry.
  858.  
  859. proc ::tk::MenuNextEntry {menu count} {
  860.     if {[$menu index last] eq "none"} {
  861.     return
  862.     }
  863.     set length [expr {[$menu index last]+1}]
  864.     set quitAfter $length
  865.     set active [$menu index active]
  866.     if {$active eq "none"} {
  867.     set i 0
  868.     } else {
  869.     set i [expr {$active + $count}]
  870.     }
  871.     while {1} {
  872.     if {$quitAfter <= 0} {
  873.         # We've tried every entry in the menu.  Either there are
  874.         # none, or they're all disabled.  Just give up.
  875.  
  876.         return
  877.     }
  878.     while {$i < 0} {
  879.         incr i $length
  880.     }
  881.     while {$i >= $length} {
  882.         incr i -$length
  883.     }
  884.     if {[catch {$menu entrycget $i -state} state] == 0} {
  885.         if {$state ne "disabled" && \
  886.             ($i!=0 || [$menu cget -type] ne "tearoff" \
  887.             || [$menu type 0] ne "tearoff")} {
  888.         break
  889.         }
  890.     }
  891.     if {$i == $active} {
  892.         return
  893.     }
  894.     incr i $count
  895.     incr quitAfter -1
  896.     }
  897.     $menu activate $i
  898.     GenerateMenuSelect $menu
  899.  
  900.     if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} {
  901.     set cascade [$menu entrycget $i -menu]
  902.     if {$cascade ne ""} {
  903.         # Here we auto-post a cascade.  This is necessary when
  904.         # we traverse left/right in the menubar, but undesirable when
  905.         # we traverse up/down in a menu.
  906.         $menu postcascade $i
  907.         MenuFirstEntry $cascade
  908.     }
  909.     }
  910. }
  911.  
  912. # ::tk::MenuFind --
  913. # This procedure searches the entire window hierarchy under w for
  914. # a menubutton that isn't disabled and whose underlined character
  915. # is "char" or an entry in a menubar that isn't disabled and whose
  916. # underlined character is "char".
  917. # It returns the name of that window, if found, or an
  918. # empty string if no matching window was found.  If "char" is an
  919. # empty string then the procedure returns the name of the first
  920. # menubutton found that isn't disabled.
  921. #
  922. # Arguments:
  923. # w -                Name of window where key was typed.
  924. # char -            Underlined character to search for;
  925. #                may be either upper or lower case, and
  926. #                will match either upper or lower case.
  927.  
  928. proc ::tk::MenuFind {w char} {
  929.     set char [string tolower $char]
  930.     set windowlist [winfo child $w]
  931.  
  932.     foreach child $windowlist {
  933.     # Don't descend into other toplevels.
  934.         if {[winfo toplevel $w] ne [winfo toplevel $child]} {
  935.         continue
  936.     }
  937.     if {[winfo class $child] eq "Menu" && [$child cget -type] eq "menubar"} {
  938.         if {$char eq ""} {
  939.         return $child
  940.         }
  941.         set last [$child index last]
  942.         for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
  943.         if {[$child type $i] eq "separator"} {
  944.             continue
  945.         }
  946.         set char2 [string index [$child entrycget $i -label] \
  947.             [$child entrycget $i -underline]]
  948.         if {$char eq [string tolower $char2] || $char eq ""} {
  949.             if {[$child entrycget $i -state] ne "disabled"} {
  950.             return $child
  951.             }
  952.         }
  953.         }
  954.     }
  955.     }
  956.  
  957.     foreach child $windowlist {
  958.     # Don't descend into other toplevels.
  959.         if {[winfo toplevel $w] ne [winfo toplevel $child]} {
  960.         continue
  961.     }
  962.     switch [winfo class $child] {
  963.         Menubutton {
  964.         set char2 [string index [$child cget -text] \
  965.             [$child cget -underline]]
  966.         if {$char eq [string tolower $char2] || $char eq ""} {
  967.             if {[$child cget -state] ne "disabled"} {
  968.             return $child
  969.             }
  970.         }
  971.         }
  972.  
  973.         default {
  974.         set match [MenuFind $child $char]
  975.         if {$match ne ""} {
  976.             return $match
  977.         }
  978.         }
  979.     }
  980.     }
  981.     return {}
  982. }
  983.  
  984. # ::tk::TraverseToMenu --
  985. # This procedure implements keyboard traversal of menus.  Given an
  986. # ASCII character "char", it looks for a menubutton with that character
  987. # underlined.  If one is found, it posts the menubutton's menu
  988. #
  989. # Arguments:
  990. # w -                Window in which the key was typed (selects
  991. #                a toplevel window).
  992. # char -            Character that selects a menu.  The case
  993. #                is ignored.  If an empty string, nothing
  994. #                happens.
  995.  
  996. proc ::tk::TraverseToMenu {w char} {
  997.     variable ::tk::Priv
  998.     if {$char eq ""} {
  999.     return
  1000.     }
  1001.     while {[winfo class $w] eq "Menu"} {
  1002.     if {[$w cget -type] eq "menubar"} {
  1003.         break
  1004.     } elseif {$Priv(postedMb) eq ""} {
  1005.         return
  1006.     }
  1007.     set w [winfo parent $w]
  1008.     }
  1009.     set w [MenuFind [winfo toplevel $w] $char]
  1010.     if {$w ne ""} {
  1011.     if {[winfo class $w] eq "Menu"} {
  1012.         tk_menuSetFocus $w
  1013.         set Priv(window) $w
  1014.         SaveGrabInfo $w
  1015.         grab -global $w
  1016.         TraverseWithinMenu $w $char
  1017.     } else {
  1018.         MbPost $w
  1019.         MenuFirstEntry [$w cget -menu]
  1020.     }
  1021.     }
  1022. }
  1023.  
  1024. # ::tk::FirstMenu --
  1025. # This procedure traverses to the first menubutton in the toplevel
  1026. # for a given window, and posts that menubutton's menu.
  1027. #
  1028. # Arguments:
  1029. # w -                Name of a window.  Selects which toplevel
  1030. #                to search for menubuttons.
  1031.  
  1032. proc ::tk::FirstMenu w {
  1033.     variable ::tk::Priv
  1034.     set w [MenuFind [winfo toplevel $w] ""]
  1035.     if {$w ne ""} {
  1036.     if {[winfo class $w] eq "Menu"} {
  1037.         tk_menuSetFocus $w
  1038.         set Priv(window) $w
  1039.         SaveGrabInfo $w
  1040.         grab -global $w
  1041.         MenuFirstEntry $w
  1042.     } else {
  1043.         MbPost $w
  1044.         MenuFirstEntry [$w cget -menu]
  1045.     }
  1046.     }
  1047. }
  1048.  
  1049. # ::tk::TraverseWithinMenu
  1050. # This procedure implements keyboard traversal within a menu.  It
  1051. # searches for an entry in the menu that has "char" underlined.  If
  1052. # such an entry is found, it is invoked and the menu is unposted.
  1053. #
  1054. # Arguments:
  1055. # w -                The name of the menu widget.
  1056. # char -            The character to look for;  case is
  1057. #                ignored.  If the string is empty then
  1058. #                nothing happens.
  1059.  
  1060. proc ::tk::TraverseWithinMenu {w char} {
  1061.     if {$char eq ""} {
  1062.     return
  1063.     }
  1064.     set char [string tolower $char]
  1065.     set last [$w index last]
  1066.     if {$last eq "none"} {
  1067.     return
  1068.     }
  1069.     for {set i 0} {$i <= $last} {incr i} {
  1070.     if {[catch {set char2 [string index \
  1071.         [$w entrycget $i -label] [$w entrycget $i -underline]]}]} {
  1072.         continue
  1073.     }
  1074.     if {$char eq [string tolower $char2]} {
  1075.         if {[$w type $i] eq "cascade"} {
  1076.         $w activate $i
  1077.         $w postcascade active
  1078.         event generate $w <<MenuSelect>>
  1079.         set m2 [$w entrycget $i -menu]
  1080.         if {$m2 ne ""} {
  1081.             MenuFirstEntry $m2
  1082.         }
  1083.         } else {
  1084.         MenuUnpost $w
  1085.         uplevel #0 [list $w invoke $i]
  1086.         }
  1087.         return
  1088.     }
  1089.     }
  1090. }
  1091.  
  1092. # ::tk::MenuFirstEntry --
  1093. # Given a menu, this procedure finds the first entry that isn't
  1094. # disabled or a tear-off or separator, and activates that entry.
  1095. # However, if there is already an active entry in the menu (e.g.,
  1096. # because of a previous call to tk::PostOverPoint) then the active
  1097. # entry isn't changed.  This procedure also sets the input focus
  1098. # to the menu.
  1099. #
  1100. # Arguments:
  1101. # menu -        Name of the menu window (possibly empty).
  1102.  
  1103. proc ::tk::MenuFirstEntry menu {
  1104.     if {$menu eq ""} {
  1105.     return
  1106.     }
  1107.     tk_menuSetFocus $menu
  1108.     if {[$menu index active] ne "none"} {
  1109.     return
  1110.     }
  1111.     set last [$menu index last]
  1112.     if {$last eq "none"} {
  1113.     return
  1114.     }
  1115.     for {set i 0} {$i <= $last} {incr i} {
  1116.     if {([catch {set state [$menu entrycget $i -state]}] == 0) \
  1117.         && $state ne "disabled" \
  1118.         && [$menu type $i] ne "tearoff"} {
  1119.         $menu activate $i
  1120.         GenerateMenuSelect $menu
  1121.         # Only post the cascade if the current menu is a menubar;
  1122.         # otherwise, if the first entry of the cascade is a cascade,
  1123.         # we can get an annoying cascading effect resulting in a bunch of
  1124.         # menus getting posted (bug 676)
  1125.         if {[$menu type $i] eq "cascade" &&    [$menu cget -type] eq "menubar"} {
  1126.         set cascade [$menu entrycget $i -menu]
  1127.         if {$cascade ne ""} {
  1128.             $menu postcascade $i
  1129.             MenuFirstEntry $cascade
  1130.         }
  1131.         }
  1132.         return
  1133.     }
  1134.     }
  1135. }
  1136.  
  1137. # ::tk::MenuFindName --
  1138. # Given a menu and a text string, return the index of the menu entry
  1139. # that displays the string as its label.  If there is no such entry,
  1140. # return an empty string.  This procedure is tricky because some names
  1141. # like "active" have a special meaning in menu commands, so we can't
  1142. # always use the "index" widget command.
  1143. #
  1144. # Arguments:
  1145. # menu -        Name of the menu widget.
  1146. # s -            String to look for.
  1147.  
  1148. proc ::tk::MenuFindName {menu s} {
  1149.     set i ""
  1150.     if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
  1151.     catch {set i [$menu index $s]}
  1152.     return $i
  1153.     }
  1154.     set last [$menu index last]
  1155.     if {$last eq "none"} {
  1156.     return
  1157.     }
  1158.     for {set i 0} {$i <= $last} {incr i} {
  1159.     if {![catch {$menu entrycget $i -label} label]} {
  1160.         if {$label eq $s} {
  1161.         return $i
  1162.         }
  1163.     }
  1164.     }
  1165.     return ""
  1166. }
  1167.  
  1168. # ::tk::PostOverPoint --
  1169. # This procedure posts a given menu such that a given entry in the
  1170. # menu is centered over a given point in the root window.  It also
  1171. # activates the given entry.
  1172. #
  1173. # Arguments:
  1174. # menu -        Menu to post.
  1175. # x, y -        Root coordinates of point.
  1176. # entry -        Index of entry within menu to center over (x,y).
  1177. #            If omitted or specified as {}, then the menu's
  1178. #            upper-left corner goes at (x,y).
  1179.  
  1180. proc ::tk::PostOverPoint {menu x y {entry {}}}  {
  1181.     global tcl_platform
  1182.     
  1183.     if {$entry ne ""} {
  1184.     if {$entry == [$menu index last]} {
  1185.         incr y [expr {-([$menu yposition $entry] \
  1186.             + [winfo reqheight $menu])/2}]
  1187.     } else {
  1188.         incr y [expr {-([$menu yposition $entry] \
  1189.             + [$menu yposition [expr {$entry+1}]])/2}]
  1190.     }
  1191.     incr x [expr {-[winfo reqwidth $menu]/2}]
  1192.     }
  1193.     if {$tcl_platform(platform) eq "windows"} {
  1194.     # We need to fix some problems with menu posting on Windows,
  1195.     # where, if the menu would overlap top or bottom of screen,
  1196.     # Windows puts it in the wrong place for us.  We must also
  1197.     # subtract an extra amount for half the height of the current
  1198.     # entry.  To be safe we subtract an extra 10.
  1199.     set yoffset [expr {[winfo screenheight $menu] \
  1200.         - $y - [winfo reqheight $menu] - 10}]
  1201.     if {$yoffset < 0} {
  1202.         # The bottom of the menu is offscreen, so adjust upwards
  1203.         incr y $yoffset
  1204.         if {$y < 0} { set y 0 }
  1205.     }
  1206.     # If we're off the top of the screen (either because we were
  1207.     # originally or because we just adjusted too far upwards),
  1208.     # then make the menu popup on the top edge.
  1209.     if {$y < 0} {
  1210.         set y 0
  1211.     }
  1212.     }
  1213.     $menu post $x $y
  1214.     if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
  1215.     $menu activate $entry
  1216.     GenerateMenuSelect $menu
  1217.     }
  1218. }
  1219.  
  1220. # ::tk::SaveGrabInfo --
  1221. # Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record
  1222. # the state of any existing grab on the w's display.
  1223. #
  1224. # Arguments:
  1225. # w -            Name of a window;  used to select the display
  1226. #            whose grab information is to be recorded.
  1227.  
  1228. proc tk::SaveGrabInfo w {
  1229.     variable ::tk::Priv
  1230.     set Priv(oldGrab) [grab current $w]
  1231.     if {$Priv(oldGrab) ne ""} {
  1232.     set Priv(grabStatus) [grab status $Priv(oldGrab)]
  1233.     }
  1234. }
  1235.  
  1236. # ::tk::RestoreOldGrab --
  1237. # Restores the grab to what it was before TkSaveGrabInfo was called.
  1238. #
  1239.  
  1240. proc ::tk::RestoreOldGrab {} {
  1241.     variable ::tk::Priv
  1242.  
  1243.     if {$Priv(oldGrab) ne ""} {
  1244.         # Be careful restoring the old grab, since it's window may not
  1245.     # be visible anymore.
  1246.  
  1247.     catch {
  1248.           if {$Priv(grabStatus) eq "global"} {
  1249.         grab set -global $Priv(oldGrab)
  1250.         } else {
  1251.         grab set $Priv(oldGrab)
  1252.         }
  1253.     }
  1254.     set Priv(oldGrab) ""
  1255.     }
  1256. }
  1257.  
  1258. proc ::tk_menuSetFocus {menu} {
  1259.     variable ::tk::Priv
  1260.     if {![info exists Priv(focus)] || $Priv(focus) eq ""} {
  1261.     set Priv(focus) [focus]
  1262.     }
  1263.     focus $menu
  1264. }
  1265.  
  1266. proc ::tk::GenerateMenuSelect {menu} {
  1267.     variable ::tk::Priv
  1268.  
  1269.     if {$Priv(activeMenu) eq $menu && $Priv(activeItem) eq [$menu index active]} {
  1270.     return
  1271.     }
  1272.  
  1273.     set Priv(activeMenu) $menu
  1274.     set Priv(activeItem) [$menu index active]
  1275.     event generate $menu <<MenuSelect>>
  1276. }
  1277.  
  1278. # ::tk_popup --
  1279. # This procedure pops up a menu and sets things up for traversing
  1280. # the menu and its submenus.
  1281. #
  1282. # Arguments:
  1283. # menu -        Name of the menu to be popped up.
  1284. # x, y -        Root coordinates at which to pop up the
  1285. #            menu.
  1286. # entry -        Index of a menu entry to center over (x,y).
  1287. #            If omitted or specified as {}, then menu's
  1288. #            upper-left corner goes at (x,y).
  1289.  
  1290. proc ::tk_popup {menu x y {entry {}}} {
  1291.     variable ::tk::Priv
  1292.     global tcl_platform
  1293.     if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} {
  1294.     tk::MenuUnpost {}
  1295.     }
  1296.     tk::PostOverPoint $menu $x $y $entry
  1297.     if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} {
  1298.         tk::SaveGrabInfo $menu
  1299.     grab -global $menu
  1300.     set Priv(popup) $menu
  1301.     tk_menuSetFocus $menu
  1302.     }
  1303. }
  1304.